home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 24 / CU Amiga Magazine's Super CD-ROM 24 (1998)(EMAP Images)(GB)(Track 1 of 2)[!][issue 1998-07].iso / CUCD / Programming / SWI / source / lisp / qptokens.el < prev    next >
Encoding:
Text File  |  1992-05-26  |  7.6 KB  |  260 lines
  1. ;;;  SCCS: @(#)90/11/15 qptokens.el    2.3
  2. ;;;            Quintus Prolog - GNU Emacs Interface
  3. ;;;                         Support Functions
  4. ;;;
  5. ;;;                Consolidated by Sitaram Muralidhar
  6. ;;;
  7. ;;;                   sitaram@quintus.com
  8. ;;;              Quintus Computer Systems, Inc.
  9. ;;;                  2 May 1989       
  10. ;;;
  11. ;;; This file defines functions that support the Quintus Prolog - GNU Emacs
  12. ;;; interface.
  13. ;;;
  14. ;;;                   Acknowledgements
  15. ;;;
  16. ;;
  17. ;;; This interface was made possible by contributions from Fernando
  18. ;;; Pereira and various customers of Quintus Computer Systems, Inc.,
  19. ;;; based on code for Quintus's Unipress Emacs interface.
  20. ;;; 
  21.  
  22. ;;; Functions defined in this file are:
  23. ;;;   - region-to-string()
  24. ;;;   - BadToken(message)
  25. ;;;   - next-token()
  26. ;;;   - pre-preceding-char()
  27.  
  28.  
  29. (defun region-to-string ()
  30.   (buffer-substring (min (point) (mark)) (max (point) (mark))))
  31.  
  32. (defmacro pattern-at-point (x)
  33.   (list 'and (list 'looking-at x) '(goto-char (match-end 0)) t))
  34.  
  35. (defvar *digits*
  36.   "0123456789AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZz")
  37.  
  38. (defvar *character-escapes* nil)
  39.  
  40. (defun BadToken (message)
  41.   (error message))
  42.  
  43. (defun pre-preceding-char ()
  44.   (let (char)
  45.     (if (bobp)
  46.         (setq char -1)
  47.       (progn
  48.         (backward-char)
  49.         (setq char (preceding-char))
  50.         (forward-char)))
  51.     char
  52.     ))
  53.  
  54. (defun next-token ()
  55.   (let ((char (following-char)) ttype)
  56.     (set-mark (point))
  57.     (cond 
  58.      ((eobp) (setq ttype "eof"))
  59.      ((and (>= char ?a) (<= char ?z))
  60.       (forward-char)
  61.       (pattern-at-point "[A-Za-z_0-9]*")
  62.       (if (= (following-char) ?\()
  63.           (setq ttype "functor")
  64.         (setq ttype "atom")))
  65.      ((or (and (>= char ?\001) (<= char ? )) (= char ?\177))
  66.       (forward-char)
  67.       (pattern-at-point "[\001- \177]*")
  68.       (setq ttype (next-token)))
  69.      ((or 
  70.        (= char ?,) (= char ?\) ) (= char ?\( ) 
  71.        (= char ?\| ) (= char ?]) (= char ?}))
  72.       (forward-char)
  73.       (setq ttype (char-to-string char)))
  74.      ((and (>= char ?A) (<= char ?Z))
  75.       (forward-char)
  76.       (pattern-at-point  "[A-Za-z_0-9]*")
  77.       (setq ttype "variable"))
  78.      ((or (= char ?#) (= char ?$) (= char ?&) (= char ?*) (= char ?+)
  79.           (= char ?-) (= char ?:) (= char ?<) (= char ?=) (= char ?>)
  80.           (= char ?\?) (= char ?@) (= char ?\\) (= char ?^) (= char ?`)
  81.           (= char ?~))
  82.       (forward-char)
  83.       (pattern-at-point "[-+*/\\^<>=`~:.?@#$&]*") 
  84.       (if (= (following-char) ?\( )
  85.           (setq ttype "functor")
  86.         (setq ttype "atom")
  87.         ))
  88.      ((= char ?_ )
  89.       (forward-char)
  90.       (pattern-at-point "[A-Za-z_0-9]*") 
  91.       (setq ttype "variable"))
  92.      ((and (>= char ?0) (<= char ?9))
  93.       (forward-char)
  94.       (pattern-at-point  "[0-9]*")
  95.       (if (= (following-char) ?\')
  96.           (let  ((base (string-to-int (region-to-string))) x)
  97.             (cond 
  98.              ((= base 0) (setq ttype "integer"))
  99.              ((< base 10)
  100.               (forward-char)
  101.               (setq x (substring *digits* 0 base))
  102.               (if  (pattern-at-point (concat "[" x "][" x "]*"))
  103.                   (setq ttype "integer")
  104.                 (progn 
  105.                   (backward-char)
  106.                   (setq ttype "integer"))
  107.  
  108.                 )
  109.               )
  110.              ((< base 37)
  111.               (forward-char)
  112.               (setq x (substring *digits* 0 (+ 10 (* 2 (- base 10)))))
  113.               (if (pattern-at-point (concat "[" x "][" x "]*"))
  114.                   (setq ttype "integer")             
  115.                 (progn 
  116.                   (backward-char)
  117.                   (setq ttype "integer"))
  118.                 )
  119.               )
  120.              (t (setq ttype "integer"))
  121.              )
  122.             )
  123.         (if (= (following-char) ?.)
  124.             (progn 
  125.               (forward-char)
  126.               (if (or (eobp) (looking-at "[?\001- ?\177]"))
  127.                   (progn 
  128.                     (backward-char)
  129.                     (setq ttype "integer"))
  130.                 (if (not (pattern-at-point "[0-9][0-9]*"))
  131.                     (BadToken "Floating point number has no decimal digits")
  132.                   (if (not (pattern-at-point "[eE]"))
  133.                       (setq ttype "float")
  134.                     (if (and (not (pattern-at-point "[0-9][0-9]*"))
  135.                              (not (pattern-at-point "[-+][0-9][0-9]*")))
  136.                         (progn 
  137.                           (backward-char)
  138.                           (setq ttype "float")
  139.                           )
  140.                       (setq ttype "float")
  141.                       )
  142.                     )
  143.                   )
  144.                 )
  145.               )
  146.           (setq ttype "integer")
  147.           )
  148.         )
  149.       )
  150.      ((= char ?.)
  151.       (forward-char)
  152.       (if (and (not (eobp))
  153.                (not (pattern-at-point "[\001- \177]")))
  154.           (progn 
  155.             (pattern-at-point "[-+*/\\^<>=`~:.?@#$&]*")
  156.             (if (= (following-char) ?\( )
  157.                 (setq ttype "functor")
  158.               (setq ttype "atom")))
  159.         (setq ttype "stop")))
  160.      ((= char ?\')
  161.       (let ((continue t))
  162.         (forward-char)
  163.         (while continue
  164.           (if (not (search-forward "'" nil t))
  165.               (BadToken "Quoted atom not closed")
  166.             (if *character-escapes*
  167.                 (if (not (= (pre-preceding-char) ?\\))
  168.                     (if (not (pattern-at-point "'"))
  169.                         (setq continue nil)))
  170.               (if (not (pattern-at-point "'"))
  171.                   (setq continue nil)))))
  172.         (if (= (following-char) ?\( )
  173.             (setq ttype "functor")
  174.           (setq ttype "atom")
  175.           )))
  176.      ((= char ?% )
  177.       (forward-char)
  178.       (pattern-at-point ".*\n")
  179.       (setq ttype (next-token)))
  180.      ((= char ?/)
  181.       (forward-char)
  182.       (if (not (pattern-at-point "\\*"))
  183.           (progn 
  184.             (pattern-at-point "[-+*/\\^<>=`~:.?@#$&]*")
  185.             (if (= (following-char) ?\( )
  186.                 (setq ttype "functor")
  187.               (setq ttype "atom")
  188.               )
  189.             )
  190.         (if (not (search-forward "*/" nil t))
  191.             (BadToken "Delimited comment not closed")
  192.           (setq ttype (next-token))
  193.           )
  194.         )
  195.       )
  196.      ((or (= char ?!) (= char ?\; ))
  197.       (forward-char)
  198.       (if (= (following-char) ?\( )
  199.           (setq ttype "functor")
  200.         (setq ttype "atom")
  201.         )
  202.       )
  203.      ((= char ?[ )
  204.       (forward-char)
  205.       (if (= (following-char) ?])
  206.           (progn 
  207.             (forward-char)
  208.             (if (= (following-char) ?\( )
  209.                 (setq ttype "functor")
  210.               (setq ttype "atom")
  211.               )
  212.             )
  213.         (setq ttype "[")
  214.         )
  215.       )
  216.      ((= char ?\")
  217.       (let  ((continue t))
  218.         (forward-char)
  219.         (while continue
  220.           (if (not (search-forward """" nil t))
  221.               (BadToken "Quoted string not closed")
  222.             (if *character-escapes*
  223.                 (if (not (= (pre-preceding-char) ?\\))
  224.                     (if (not (pattern-at-point "\""))
  225.                         (setq continue nil)
  226.                       )
  227.                   )
  228.               (if (not (pattern-at-point "\""))
  229.                   (setq continue nil)
  230.                 )
  231.               )
  232.             )
  233.           )
  234.         (setq ttype "string")
  235.         ))
  236.      ((= char ?{)
  237.       (forward-char)
  238.       (if (= (following-char) ?})
  239.           (progn 
  240.             (forward-char)
  241.             (if (= (following-char) ?\()
  242.                    (setq ttype "functor")
  243.                    (setq ttype "atom")
  244.                    )
  245.                 )
  246.             (setq ttype "{")
  247.             )
  248.         )
  249.      ((= char ?\000)
  250.       (forward-char)
  251.       (BadToken (concat "Cannot handle "
  252.                         (char-to-string char)
  253.                         " as a token"))
  254.       )
  255.      )
  256.     ttype
  257.     ))
  258.  
  259.  
  260.